home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / defstr.scm < prev    next >
Encoding:
Internet Message Format  |  1993-07-16  |  5.5 KB
  1. From Stewart.Clamen@B.GP.CS.CMU.EDU Tue Nov 24 17:42:26 1987
  2. Date: Tue Nov 10 15:38:17 EST 1987
  3. From: Stewart.Clamen@B.GP.CS.CMU.EDU
  4. To: mkatz@A.ISI.EDU
  5. Cc: jinx%geneva@MC.LCS.MIT.EDU
  6. Subject: define-structure
  7. Reply-To: clamen@CS.CMU.EDU
  8.  
  9.  
  10. Morry, the code you sent me had a few typos, and some extra @-signs in
  11. the body.  I assume this version does the lookup on the
  12. unsyntaxer-package at eval-time, and so doesn't include the entire
  13. runtime environment in the compile.  Here it is back to you, with some
  14. minor comments added to the head...
  15.  
  16. JINX:  "I hearby submit this macro package for the CScheme part of the
  17.         Scheme library.  It is highly implementation-dependent, and so
  18.         I expect that it is not easily portable to other Schemes."
  19.  
  20.  
  21.  
  22.  
  23.                         SMC
  24.  
  25.  
  26. - - - - - - - - - - - 
  27. ;;; An implementation of DEFSTRUCT for Scheme
  28. ;;; Stewart M Clamen, 1986
  29. ;;;
  30. ;;; Brought up to date (wrt. Release 5.3) by Morris Katz, Fall 1987.
  31.  
  32. ;;;
  33. ;;; Syntax is of form:
  34. ;;;
  35. ;;;         (define-structure (<structname> <field_1> <field_2> ... <field_n>)
  36. ;;;                            <option_1>
  37. ;;;                            <option_2>
  38. ;;;                                .
  39. ;;;                                .
  40. ;;;                                .
  41. ;;;                            <option_n>)
  42. ;;;
  43. ;;;
  44. ;;; Possible options:  :UNTYPED, :PRINTASVECTOR, :PRINTASHASH
  45. ;;;
  46. ;;;     :UNTYPED means that no type checking is done when accessors or 
  47. ;;;              mutators are used on a structure.  (i.e. accessors and
  48. ;;;              mutators will operate on any vector, regardless of
  49. ;;;              whether it is actually a structure of the given type.)
  50. ;;;
  51. ;;;     :PRINTASVECTOR if a structure is typed, this causes it to
  52. ;;;                print as a vector of its fields as opposed to
  53. ;;;                the default (opaque object) which is
  54. ;;;                #[<struct-name> <addr>].  
  55. ;;;
  56. ;;;     :PRINTASHASH if a strucuture is typed, this causes it to print
  57. ;;;              as #[<struct-name> <hashed addr>] as opposed to
  58. ;;;              the default which is #[<struct-name> <addr>].
  59. ;;;              The hash address if preserved over garbage
  60. ;;;              collection. 
  61.  
  62. ;;; Utilities
  63.  
  64. (define-macro (macro-expand exp)
  65.   `(unsyntax (syntax ',exp *rep-current-syntax-table*)))
  66.  
  67.  
  68. ;;; The Define-structure Macro
  69.  
  70. (define-macro (define-structure struct . options)
  71.   (let ((structname (car struct))
  72.     (fields (cdr struct))
  73.     (untyped
  74.      (member ':UNTYPED options))    ;UNTYPED option
  75.     (print-as-hash
  76.      (member ':PRINTASHASH options)) ;PRINTASHASH option
  77.     (print-as-vector
  78.      (member ':PRINTASVECTOR options)) ;PRINTASVECTOR option
  79.     (struct-string (symbol-print-name (car struct))))
  80.     
  81.     (define (list-position l item)
  82.       (let loop ((l l) (count 0))
  83.        (if l
  84.            (if (eq? (car l) item)
  85.            count
  86.            (loop (cdr l) (+ count 1))))))
  87.     
  88.     (define ((add-prefix prefix) s)
  89.       (make-interned-symbol 
  90.        (string-append prefix "-" (symbol-print-name s))))
  91.   
  92.     (define ((add-suffix suffix) s)
  93.       (make-interned-symbol 
  94.        (string-append (symbol-print-name s) suffix)))
  95.  
  96.     (let ((tagname ((add-suffix "-TYPE") structname))
  97.       (constructor-name ((add-prefix "MAKE") structname))
  98.       (predicate-name ((add-suffix "?") structname))
  99.       (selector-names 
  100.        (mapcar (add-prefix struct-string) fields))
  101.       (mutator-names 
  102.        (mapcar (add-suffix "!") 
  103.            (mapcar (add-prefix (string-append "SET-" struct-string))
  104.                fields)))
  105.       (errmsg (string-append "Not of type " struct-string " -- ")))
  106.  
  107.       (let ((selector-definition 
  108.          (lambda (field) 
  109.            `(set! ,field
  110.               (named-lambda (,field ,structname)
  111.             (structure-ref 
  112.              ,structname 
  113.              ,(if untyped
  114.                   (list-position selector-names field)
  115.                   (1+ (list-position selector-names field))))))))
  116.         (mutator-definition 
  117.          (lambda (field) 
  118.            `(set! ,field
  119.               (named-lambda (,field ,structname val)
  120.             (structure-set!
  121.              ,structname
  122.              ,(if untyped
  123.                   (list-position mutator-names field)
  124.                   (1+ (list-position mutator-names field)))
  125.              val)))))
  126.         (make-unassigned
  127.          (lambda (procname)
  128.            `(define ,procname))))
  129.     
  130.     ;; definitions
  131.     `(sequence
  132.       ,@(mapcar make-unassigned 
  133.             (append (list constructor-name predicate-name)
  134.                 selector-names
  135.                 mutator-names))
  136.  
  137.       (let ((tag ',(list tagname)))
  138.  
  139.         ,(if untyped
  140.          `(sequence
  141.            (define structure-ref vector-ref)
  142.            (define structure-set! vector-set!)
  143.            (set! ,constructor-name
  144.              (named-lambda (,constructor-name ,@fields)
  145.                (vector ,@fields))))
  146.          `(sequence
  147.            (define (structure-ref struct slot)
  148.              (if (,predicate-name struct)
  149.              (vector-ref struct slot)
  150.              (error ,errmsg struct)))
  151.            (define (structure-set! struct slot val)
  152.              (if (,predicate-name struct)
  153.              (vector-set! struct slot val)
  154.              (error ,errmsg struct)))
  155.            (set! ,predicate-name
  156.              (named-lambda (,predicate-name ,structname)
  157.                (if (vector? ,structname) 
  158.                    (eq? (vector-ref ,structname 0) tag))))
  159.            (set! ,constructor-name
  160.              (named-lambda (,constructor-name ,@fields)
  161.                (vector tag ,@fields)))))
  162.         ,@(mapcar selector-definition selector-names)
  163.         ,@(mapcar mutator-definition mutator-names)
  164.         ,(if (and
  165.           (not untyped)
  166.           (not print-as-vector))
  167.          `((access
  168.             add-unparser-special-object!
  169.             unparser-package)
  170.            tag
  171.            (lambda (obj)
  172.              (unparse-with-brackets
  173.               (lambda ()
  174.             (write-string (string-append ,struct-string " "))
  175.             (write
  176.              ,(if (not print-as-hash)
  177.                   `(primitive-datum obj)
  178.                   `(hash obj))))))))
  179.         )
  180.       ',structname)))))
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.